home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istpf / PFLIB4.MAC.f < prev   
Encoding:
Text File  |  1989-03-04  |  27.5 KB  |  839 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4.  
  5. C type PFPU = record
  6. C               NAME: integer; (* index into NAMTXT *)
  7. C               NARGS: integer;
  8. C               ARGS: ^(heap) HEAD (PFPUARG); (* 0 = nil *)
  9. C               COMMONS: ^(heap) HEAD (PFPUCU); (* 0 for ENTRY points *)
  10. C               PARENTS: ^(heap) HEAD (PARENT); (* ditto *)
  11. C               DESC: ^(heap) HEAD (PFPUDESC);  (* ditto *)
  12. C               DTYPE: integer;
  13. C               CHRLEN: integer;
  14. C               ACTUAL: ^PFPU         (* 0 except for ENTRY points *)
  15. C             end;
  16.  
  17. C type PFEX = record
  18. C               NAME: integer;
  19. C               DTYPE: integer;
  20. C               CHRLEN: integer;
  21. C               NARGS: integer;
  22. C               ARGS: ^(heap) HEAD(PFEXARG);
  23. C               INDARG: ^PFPUARG    (* only for indirect refs *)
  24. C             end;
  25.  
  26. C type PFPUARG = record
  27. C                   DTYPE: integer;
  28. C                   CHLEN: integer;
  29. C                   case STRUC of
  30. C                       var,array: (USAGE: (arg,read,update));
  31. C                       proc: (REF: integer (EXNODE index))
  32. C                       end;
  33. C                   STRUC: (var,array,proc);
  34. C                   SIZE: integer;
  35. C                   DESC: ^(heap) HEAD (PUARGDES);
  36. C                   PROCS: ^(heap) HEAD (PFPROC);
  37. C                   PRNTS: ^(heap) HEAD (LATPAR)
  38. C                end;
  39.  
  40. C type PFEXARG = record
  41. C                   DTYPE: integer;
  42. C                   ATYPE: integer;
  43. C                   PROCS: ^(heap) HEAD (PFPROC);
  44. C                   if (DTYPE=type_char) then
  45. C                       CHMIN,CHMAX: integer
  46. C                   end if
  47. C                 end;
  48.  
  49. C type PFPUDESC = record
  50. C                   NODE: integer (* +ve => index into PUNODE,
  51. C                                    -ve => -index into EXNODE *)
  52. C                 end;
  53. C
  54. C type PFPUCU = record
  55. C                   CBNUM: integer; (* index into CBDATA *)
  56. C                   USAGE: (readonly,update)
  57. C               end;
  58.  
  59. C type PUARGDES = record
  60. C                   TYPE: (direct,indirect);
  61. C                   ANUM: integer;  (* argument number passed out as *)
  62. C                   case TYPE of
  63. C                       direct: (NODE: integer); (* PUNODE/EXNODE index *)
  64. C                       indirect: (INUM: integer)   (* arg no. passed to *)
  65. C                       end
  66. C                 end;
  67.  
  68. C type PFPROC = record
  69. C                   NODE: integer;  (* PUNODE/EXNODE index of associated pu *)
  70. C                   ASSOC: integer; (* ditto of associating pu. *)
  71. C                   STMTNO: integer (* statement number of association *)
  72. C               end;
  73.  
  74. C
  75. C type PARENT = record (* routine parent *)
  76. C                   NODE: integer   (* PUNODE index of parent routine *)
  77. C               end;
  78. C
  79. C type APARENT = record (* argument parent *)
  80. C                   NODE: integer;  (* PUNODE index of parent routine *)
  81. C                   ANUM: integer   (* argument number passed down *)
  82. C                end;
  83.  
  84. C type PFUS = record (* unsafe reference check record *)
  85. C               TYPE: 1..5;      (* unsafe reference type *)
  86. C               ASSOC: integer;  (* punode index of calling p.u. *)
  87. C               STMTNO: integer; (* statement number of reference *)
  88. C               EXTRA: integer;  (* type-dependent extra data *)
  89. C               CALLED: integer; (* punode/exnode index of called routine *)
  90. C               ARGNUM: integer  (* argument number for unsafe check *)
  91. C             end;
  92. C YXLIB Customisation Parameters
  93. C ------------------------------
  94.  
  95. C Routine Names
  96. C -------------
  97.  
  98. C Field Definitions: Parse Tree Attributes
  99. C ----------------------------------------
  100. C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
  101. C       NOT BE USED, as ordinary arithmetic is used to extract some fields
  102.  
  103. C Attribute Table Macros
  104. C ----------------------
  105.  
  106. C YXLIB Bits
  107. C ----------
  108.  
  109. C YXLIB Local Record Macros
  110. C -------------------------
  111. C   type VARX = record
  112. C                   su: integer;    (* Storage units for variable *)
  113. C                   common: ^(S_COMMON) or -maxint..-1;
  114. C                                   (* ^(common block symbol), nil (0) or
  115. C                                      negative of equivalence class number *)
  116. C                   comsize: integer;(* Offset in common or equiv class *)
  117. C                   equiv: ^EQV;    (* Pointer to equivalence link *)
  118. C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
  119. C                                   (* array information stored here *)
  120. C               end;
  121. C
  122. C   type ARRAYX = record
  123. C                   elts: integer;  (* Number of elements in the array *)
  124. C                   dims: integer;  (* Number of dimensions of the array *)
  125. C                   limits: array [1..dims] of
  126. C                               record LOWER,UPPER: integer end
  127. C                 end;
  128.  
  129.  
  130. C   type EQH = HEAD record          (* Equivalence head record *)
  131. C                       common: ^(S_COMMON) or -maxint..-1;
  132. C                       usage: set of usage_bits
  133. C                   end;
  134.  
  135. C   type EQV = LINK record          (* Equivalence variable record (link) *)
  136. C                       sudif: integer;
  137. C                       symbol: ^(S_VAR)
  138. C                   end;
  139.  
  140. C   type LPR = record
  141. C                   glob: ^(GPU) or -^(GEX);
  142. C                   nargs: integer;
  143. C                   args: array [1..nargs] of packed record
  144. C                               dtype: min_dtype..max_dtype;
  145. C                               argument_type: atype;
  146. C                               descendents: ^HEAD;
  147. C                               if dtype=type_char then
  148. C                                   min_length, max_length: integer
  149. C                               end if
  150. C                           end record
  151. C              end;
  152.  
  153. C                                   (* Argument type definitions *)
  154. C   type ATYPE = (scalar,arelm,array,proc,label);
  155. C   const min_atype = scalar; max_atype = label;
  156.  
  157. C YXLIB Record Definition: Semi-Local
  158. C -----------------------------------
  159. C   type PAREC = LINK record
  160. C                   argnum: integer; (* Argument number passed down as *)
  161. C                   prsym: ^(S_PROC); (* Procedure passed down to *)
  162. C                   argsym: ^symbol; (* Actual argument being passed down *)
  163. C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
  164. C                   stmtno: integer; (* Statement number of assoc (context) *)
  165. C                end;
  166.  
  167. C   type UNSAF = LINK record
  168. C                   code: 1..5;     (* Type of unsafe reference to be checked *)
  169. C                   argnum: integer;(* Argument number applicable *)
  170. C                   extra: anything;(* Extra data (not used by inherit_expr) *)
  171. C                   pusym: ^(S_PU); (* Context: associating program-unit *)
  172. C                   stmtno: integer;(* Context: statement number *)
  173. C                   prsym: ^(S_PROC)(* proc being called *)
  174. C                end;
  175.  
  176. C YXLIB Global Record Macros
  177. C --------------------------
  178. C
  179. C   type G_COM = record             Global common block record
  180. C                   size: integer;
  181. C                   type: (character,numeric,mixed); (* logical = numeric *)
  182. C                   save: (saved,not_saved,only_in_main);
  183. C                   init: integer   (* Number of times init'ed by block data *)
  184. C                end;
  185.  
  186. C
  187. C   type G_PU = record              Global program-unit record
  188. C                   dtype: integer;
  189. C                   chrlen: integer;
  190. C                   culist: ^HEAD;  (* common block usage list header ptr *)
  191. C                   nargs: integer;
  192. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  193. C                   entrys: ^(HEAD) record ^G_ENT end;
  194. C                   args: array [1..nargs] of gpuarg
  195. C               end;
  196.  
  197. C   type G_ENT = record
  198. C                   dtype: integer;
  199. C                   chrlen: integer;
  200. C                   pu: ^G_PU;
  201. C                   nargs: integer;
  202. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  203. C                   args: array [1..nargs] of ^guparg
  204. C                end;
  205.  
  206. C type gpuarg = record
  207. C                   dtype,chlen: integer;
  208. C                   usage: (arg,read,update);
  209. C                   struc: (scal,array,proc,label);
  210. C                   size: integer;
  211. C                   pass: ^HEAD;
  212. C                   inh: ^HEAD(inherit)
  213. C               end;
  214. C type inherit = record
  215. C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
  216. C                   ass: ^(GPU);    (* associating program-unit *)
  217. C                   snum: integer;  (* statement number of association *)
  218. C                   if (type=proc) then
  219. C                       gsyptr: ^(GPU)/-^(GEX)
  220. C                   else
  221. C                       extra: integer (* unsafe ref extra data *)
  222. C                   end if
  223.  
  224.  
  225. C Global Descendant Routine Types
  226. C -------------------------------
  227.  
  228. C Error Codes returned by YXLIB
  229. C -----------------------------
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238. C                                   parameter length
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246. C ----------------------------------------------------------------------
  247. C
  248. C       P F C H K S   -   Perform checking of PFORT-77 data structure
  249. C
  250.  
  251.         SUBROUTINE PFCHKS(NERR,NWRN)
  252.         INTEGER NERR,NWRN
  253.  
  254.         COMMON/PFERRC/NPFERR,NPFWRN
  255.         INTEGER NPFERR,NPFWRN
  256.         SAVE/PFERRC/
  257.         COMMON/PFHEAP/USHEAD,HEAP
  258.         INTEGER USHEAD,HEAP(200000)
  259.  
  260.         SAVE /PFHEAP/
  261.  
  262.         CALL PFCHCB
  263.         CALL PFSCAN
  264.         CALL PFUNSA
  265.         NERR=NPFERR
  266.         NWRN=NPFWRN
  267.         CALL PFERR('D: Heap usage = $I/$I',HEAP(2),200000,0,0)
  268.  
  269.         END
  270. C ----------------------------------------------------------------------
  271. C
  272. C       P F C H C B   -   Check Common Block usage
  273. C
  274.  
  275.         SUBROUTINE PFCHCB
  276.  
  277.         COMMON/PFCB/NCB,CBDATA
  278.         INTEGER NCB,CBDATA(6,250)
  279.         SAVE /PFCB/
  280.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  281.         INTEGER NPUS,MAINND,PUNODE(500)
  282.         SAVE /PFPU/
  283.         COMMON/PFHEAP/USHEAD,HEAP
  284.         INTEGER USHEAD,HEAP(200000)
  285.  
  286.         SAVE /PFHEAP/
  287.         COMMON/PFNAME/NAMTXT
  288.         COMMON/PFNAMI/NNAMES,NAMEPU
  289.         CHARACTER*6 NAMTXT(800)
  290.         INTEGER NNAMES,NAMEPU(800)
  291.         SAVE /PFNAME/,/PFNAMI/
  292.  
  293.         INTEGER NOTDON,NOCB,VISIT,YESCB
  294.         PARAMETER (NOTDON=0,NOCB=1,VISIT=2,YESCB=3)
  295.  
  296.         INTEGER STATE(500),I,OCCURN,CB,LK
  297.  
  298.         INTEGER LLFIRS,LLNEXT,LLFIND
  299.         EXTERNAL LLFIRS,LLNEXT,LLFIND
  300.  
  301.         IF (MAINND.EQ.0) THEN
  302.             CALL PFERR('W: No main program - common block usage n'//
  303.      +                 'ot checked',0,0,0,0)
  304.             RETURN
  305.         END IF
  306. C
  307. C For each common block
  308.         DO 700 CB=1,NCB
  309. C
  310. C Which isn't blank common ...
  311.             IF (NAMTXT(CBDATA(1,CB)).EQ.'$COMMO') GOTO 700
  312. C
  313. C And isn't SAVE'd
  314.             IF (CBDATA(4,CB).EQ.1) GOTO 700
  315. C
  316. C Check its usage - first set all p.u. nodes to "not visited"
  317.             DO 100 I=1,NPUS
  318.                 STATE(I)=NOTDON
  319.  100        CONTINUE
  320. C
  321. C We start by visiting the main node, count occurrences of the cb
  322.             STATE(MAINND)=VISIT
  323.             OCCURN=0
  324. C
  325. C Find a node we should visit
  326.  200        DO 500 I=1,NPUS
  327.                 IF (STATE(I).EQ.VISIT) THEN
  328. C Found one, see if this common occurs in it
  329.                     IF (LLFIND(HEAP,
  330.      +                         HEAP(PUNODE(I)+3),
  331.      +                         0,
  332.      +                         CB).EQ.0) THEN
  333. C Common block doesn't occur here - mark this node & process desc.s
  334.                         STATE(I)=NOCB
  335.                         LK=HEAP(PUNODE(I)+5)
  336.                         IF (LK.NE.0) THEN
  337.                             LK=LLFIRS(HEAP,LK)
  338. C Say to visit all descendents which haven't been done elsewhere
  339.  300                        IF (STATE(HEAP(LK)).EQ.NOTDON)
  340.      +                          STATE(HEAP(LK))=VISIT
  341.                             LK=LLNEXT(HEAP,LK)
  342.                             IF (LK.NE.0) GOTO 300
  343.                         END IF
  344.                     ELSE
  345. C Common block occurs here - mark the node & count it
  346.                         STATE(I)=YESCB
  347.                         OCCURN=OCCURN+1
  348.                     END IF
  349. C Once we found a visited node, look for another from the beginning
  350.                     GOTO 200
  351.                 END IF
  352.  500        CONTINUE
  353. C Reach here once there are no more nodes to visit
  354. C At this point we check for illegal usage
  355.             IF (OCCURN.GT.1) THEN
  356.                 CALL PFERR(
  357.      +'E: Probable illegal use of common block /$T/',CBDATA(1,CB),0,0,0)
  358.                 LK=0
  359.                 DO 600 I=1,NPUS
  360.                     IF (STATE(I).EQ.YESCB) THEN
  361.                         IF (LK.EQ.0) THEN
  362.                             LK=PUNODE(I)
  363.                         ELSE IF (OCCURN.NE.0) THEN
  364.                             CALL PFERR(
  365.      +                           ' Which appeared in $N a'//'nd $N',
  366.      +                          LK,PUNODE(I),0,0)
  367.                             OCCURN=0
  368.                         ELSE
  369.                             CALL PFERR(' a'//'nd $N',PUNODE(I),0,0,0)
  370.                         END IF
  371.                     END IF
  372.  600            CONTINUE
  373.             END IF
  374.  700    CONTINUE
  375.  
  376.         END
  377. C ----------------------------------------------------------------------
  378. C
  379. C       P F S C A N   -   Percolate argument-setting and common-usage
  380. C                         information up the call tree
  381. C
  382.  
  383.         SUBROUTINE PFSCAN
  384.  
  385.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  386.         INTEGER NPUS,MAINND,PUNODE(500)
  387.         SAVE /PFPU/
  388.         COMMON/PFHEAP/USHEAD,HEAP
  389.         INTEGER USHEAD,HEAP(200000)
  390.  
  391.         SAVE /PFHEAP/
  392.         COMMON/PFPULV/ PULVL
  393.         INTEGER PULVL(500)
  394.         SAVE /PFPULV/
  395.  
  396.         LOGICAL VISITD(500),UPDATD
  397.         INTEGER I,STACK(500),CUR,SP,APAR,ARGNUM,ARG,PARG,CB,CU,PAR,
  398.      +          PARX,PARCU,TMP(2)
  399. C
  400. C Stack entry:  STACK(n)=pointer to parent record we are currently
  401. C                        traversing from.
  402.  
  403.         INTEGER LLFIRS,LLNEXT,LLFIND,LLCRHE,LLCRED
  404.         EXTERNAL LLFIRS,LLNEXT,LLFIND,LLCRHE,LLCRED,LLINTO
  405.  
  406.         DO 100 I=1,NPUS
  407.             VISITD(I)=.FALSE.
  408.  100    CONTINUE
  409. C
  410. C Say we have visited the main node(s)
  411.         IF (MAINND.NE.0) THEN
  412.             VISITD(MAINND)=.TRUE.
  413.         ELSE
  414.             DO 150 I=1,NPUS
  415.                 IF (PULVL(I).EQ.0) VISITD(I)=.TRUE.
  416.  150        CONTINUE
  417.             CALL PFERR('W: Attempting to scan incomplete program',0,0,
  418.      +                 0,0)
  419.         END IF
  420. C
  421. C Cycle through all terminal nodes which have parents
  422.         DO 900 I=1,NPUS
  423.             IF (HEAP(PUNODE(I)+5).EQ.0 .AND.
  424.      +          HEAP(PUNODE(I)+4).NE.0) THEN
  425. C
  426. C Found a terminal node; start recursive traverse of all paths upwards
  427. C from it to the root.
  428.                 CUR=I
  429.                 SP=0
  430. C
  431. C Node processing:
  432. C   1. For each argument which is set and also has parent links, mark
  433. C      parent arguments as set.
  434. C   2. Add each common region to parents' list of common regions
  435. C   3. Step to first parent node, or
  436. C      Step to next node at this level, or
  437. C      Backup one level (finish if reach top of stack).
  438. C   X. Only perform step 3 if not visited this node previously or
  439. C      we actually made some change (to an argument or common block)
  440.  200            UPDATD=.NOT.VISITD(CUR)
  441.                 VISITD(CUR)=.TRUE.
  442.                 CUR=PUNODE(CUR)
  443. C
  444. C Argument processing
  445.                 IF (HEAP(CUR+2).NE.0) THEN
  446.                     ARG=LLFIRS(HEAP,HEAP(CUR+2))
  447.  300                IF (HEAP(ARG+2).EQ.2 .AND.
  448.      +                  HEAP(ARG+7).NE.0) THEN
  449. C Set parent arg
  450.                         APAR=LLFIRS(HEAP,HEAP(ARG+7))
  451.  400                    ARGNUM=HEAP(APAR+1)
  452.                         PARG=LLFIRS(HEAP,
  453.      +HEAP(PUNODE(HEAP(APAR+0))+2))
  454.  500                    IF (ARGNUM.GT.1) THEN
  455.                             ARGNUM=ARGNUM-1
  456.                             PARG=LLNEXT(HEAP,PARG)
  457.                             GOTO 500
  458.                         END IF
  459.                         IF (HEAP(PARG+2).NE.2)
  460.      +                      UPDATD=.TRUE.
  461.                         HEAP(PARG+2)=2
  462.                         APAR=LLNEXT(HEAP,APAR)
  463.                         IF (APAR.NE.0) GOTO 400
  464.                     END IF
  465.                     ARG=LLNEXT(HEAP,ARG)
  466.                     IF (ARG.NE.0) GOTO 300
  467.                 END IF
  468. C
  469. C Common processing
  470.                 IF (HEAP(CUR+3).NE.0 .AND.
  471.      +              HEAP(CUR+4).NE.0) THEN
  472. C For each common in use
  473.                     CU=LLFIRS(HEAP,HEAP(CUR+3))
  474.  600                IF (HEAP(CU+1).NE.0) THEN
  475. C ... which is updated
  476.                         PARX=LLFIRS(HEAP,HEAP(CUR+4))
  477. C ... check all parent routines
  478.  700                    PAR=PUNODE(HEAP(PARX))
  479. C Find their usage record for this common if any
  480.                         PARCU=LLFIND(HEAP,HEAP(PAR+3),
  481.      +                               0,
  482.      +                               HEAP(CU+0))
  483.                         IF (PARCU.EQ.0) THEN
  484. C ... Not there - create a new one
  485.                             UPDATD=.TRUE.
  486.                             TMP(1+0)=HEAP(CU+0)
  487.                             TMP(1+1)=1
  488.                             IF (HEAP(PAR+3).EQ.0)
  489.      +                          HEAP(PAR+3)=LLCRHE(HEAP,0)
  490.                             CALL LLINTO(HEAP,
  491.      +                                  LLCRED(HEAP,2,TMP),
  492.      +                                  HEAP(PAR+3))
  493.                         ELSE
  494. C ... Found it - make sure it says "update"
  495.                             IF (HEAP(PARCU+1).NE.1)
  496.      +                          UPDATD=.TRUE.
  497.                             HEAP(PARCU+1)=1
  498.                         END IF
  499. C Loop over parents
  500.                         PARX=LLNEXT(HEAP,PARX)
  501.                         IF (PARX.NE.0) GOTO 700
  502.                     END IF
  503. C Loop over commons
  504.                     CU=LLNEXT(HEAP,CU)
  505.                     IF (CU.NE.0) GOTO 600
  506.                 END IF
  507. C
  508. C Pick new parent - but not if it would be an unnecessary traversal
  509.                 IF (UPDATD .AND. HEAP(CUR+4).NE.0) THEN
  510. C This routine has parents so do them
  511.                     SP=SP+1
  512.                     CUR=LLFIRS(HEAP,HEAP(CUR+4))
  513.                     STACK(SP)=LLNEXT(HEAP,CUR)
  514.                     CUR=HEAP(CUR)
  515.                     GOTO 200
  516.                 ELSE IF (SP.GT.0) THEN
  517. C There is something on the stack maybe?
  518.  800                IF (STACK(SP).NE.0) THEN
  519. C Yes - do it
  520.                         CUR=HEAP(STACK(SP))
  521.                         STACK(SP)=LLNEXT(HEAP,STACK(SP))
  522.                         GOTO 200
  523.                     ELSE
  524. C Finished top list, backup one level
  525.                         SP=SP-1
  526.                         IF (SP.GT.0) GOTO 800
  527.                     END IF
  528.                 END IF
  529. C Finished all possible parents for that terminal node
  530.             END IF
  531.  900    CONTINUE
  532.  
  533.         END
  534. C ----------------------------------------------------------------------
  535. C
  536. C       P F U N S A   -   Check for unsafe references
  537. C
  538.  
  539.         SUBROUTINE PFUNSA
  540.  
  541.         COMMON/PFHEAP/USHEAD,HEAP
  542.         INTEGER USHEAD,HEAP(200000)
  543.  
  544.         SAVE /PFHEAP/
  545.  
  546.         INTEGER USREF
  547.  
  548.         EXTERNAL PFCHU1,PFCHU2,PFCHU3,PFCHU4,PFCHU5
  549.  
  550.         INTEGER LLFIRS,LLNEXT
  551.         EXTERNAL LLFIRS,LLNEXT
  552.  
  553.         USREF=LLFIRS(HEAP,USHEAD)
  554.         IF (USREF.NE.0) THEN
  555.  100        IF (HEAP(USREF+0).EQ.1) THEN
  556.                 CALL PFCHUS(PFCHU1,HEAP(USREF))
  557.             ELSE IF (HEAP(USREF+0).EQ.3) THEN
  558.                 CALL PFCHUS(PFCHU3,HEAP(USREF))
  559.             ELSE IF (HEAP(USREF+0).EQ.2) THEN
  560.                 CALL PFCHUS(PFCHU2,HEAP(USREF))
  561.             ELSE IF (HEAP(USREF+0).EQ.4) THEN
  562.                 CALL PFCHUS(PFCHU4,HEAP(USREF))
  563.             ELSE IF (HEAP(USREF+0).EQ.5) THEN
  564.                 CALL PFCHUS(PFCHU5,HEAP(USREF))
  565.             ELSE
  566.                 CALL PFERR('I: (PFUNSA) Unknown reference type = $I',
  567.      +                     HEAP(USREF+0),0,0,0)
  568.             END IF
  569.             USREF=LLNEXT(HEAP,USREF)
  570.             IF (USREF.NE.0) GOTO 100
  571.         END IF
  572.  
  573.         END
  574. C ----------------------------------------------------------------------
  575. C
  576. C       P F C H U S   -   Check a (possibly list of) unsafe ref(s)
  577. C
  578.  
  579.         SUBROUTINE PFCHUS(CHECK,PFUS)
  580.         EXTERNAL CHECK
  581.         INTEGER PFUS(0:6-1)
  582.  
  583.         COMMON/PFPU/ NPUS,MAINND,PUNODE
  584.         INTEGER NPUS,MAINND,PUNODE(500)
  585.         SAVE /PFPU/
  586.         COMMON/PFEXTS/NEXTS,EXNODE
  587.         INTEGER NEXTS,EXNODE(500)
  588.         SAVE /PFEXTS/
  589.         COMMON/PFHEAP/USHEAD,HEAP
  590.         INTEGER USHEAD,HEAP(200000)
  591.  
  592.         SAVE /PFHEAP/
  593.  
  594.         INTEGER ARG,PROCPX
  595.  
  596.         INTEGER LLFIRS,LLNEXT
  597.         EXTERNAL LLFIRS,LLNEXT
  598.  
  599.         IF (PFUS(4).GT.0) THEN
  600.             CALL CHECK(PUNODE(PFUS(4)),PFUS(5),
  601.      +                 PFUS(3),PUNODE(PFUS(1)),
  602.      +                 PFUS(2))
  603.         ELSE IF (PFUS(4).LT.0) THEN
  604.             ARG=HEAP(EXNODE(-PFUS(4))+5)
  605.             IF (ARG.EQ.0) CALL PFERR(
  606.      +'F: Cannot resolve unsafe indirect ref from $N at statement $I',
  607.      +                 PUNODE(PFUS(1)),PFUS(2),0,0)
  608.             IF (HEAP(ARG+6).EQ.0) THEN
  609.                 CALL PFERR(
  610.      +'W: No valid procedure args for reference from $N at stmt $I',
  611.      +                 PUNODE(PFUS(1)),PFUS(2),0,0)
  612.                 RETURN
  613.             END IF
  614.             PROCPX=LLFIRS(HEAP,HEAP(ARG+6))
  615.  100        CALL CHECK(PUNODE(HEAP(PROCPX+0)),
  616.      +                 PFUS(5),PFUS(3),
  617.      +                 PUNODE(PFUS(1)),PFUS(2))
  618.             PROCPX=LLNEXT(HEAP,PROCPX)
  619.             IF (PROCPX.NE.0) GOTO 100
  620.         ELSE
  621.             CALL PFERR(
  622.      +'F: Cannot resolve unsafe reference from $N at statement $I',
  623.      +                 PUNODE(PFUS(1)),PFUS(2),0,0)
  624.         END IF
  625.  
  626.         END
  627. C ----------------------------------------------------------------------
  628. C
  629. C       P F C H U 1   -   Check a possibly unsafe reference of type 1
  630. C                         (expression supplied as update argument)
  631. C
  632.  
  633.         SUBROUTINE PFCHU1(ROUTIN,ARGNUM,EXTRA,ASSOC,STMTNO)
  634.         INTEGER ROUTIN,ARGNUM,EXTRA,ASSOC,STMTNO
  635.  
  636.         COMMON/PFHEAP/USHEAD,HEAP
  637.         INTEGER USHEAD,HEAP(200000)
  638.  
  639.         SAVE /PFHEAP/
  640.  
  641.         INTEGER ARG,COUNT
  642.  
  643.         INTEGER LLFIRS,LLNEXT
  644.         EXTERNAL LLFIRS,LLNEXT
  645.  
  646.         COUNT=1
  647.         ARG=LLFIRS(HEAP,HEAP(ROUTIN+2))
  648.  100    IF (COUNT.LT.ARGNUM) THEN
  649.             COUNT=COUNT+1
  650.             ARG=LLNEXT(HEAP,ARG)
  651.             GOTO 100
  652.         END IF
  653.         IF (HEAP(ARG+2).EQ.2) THEN
  654.             CALL PFERR(
  655.      +'E: Type 1 unsafe reference to $N from $N at statement $I',
  656.      +          ROUTIN,ASSOC,STMTNO,0)
  657.             CALL PFERR(' Expression supplied to updated argument $I',
  658.      +                  ARGNUM,0,0,0)
  659.         END IF
  660.  
  661.         END
  662. C ----------------------------------------------------------------------
  663. C
  664. C       P F C H U 2   -   Check a possibly unsafe reference of type 2
  665. C
  666.  
  667.         SUBROUTINE PFCHU2(ROUTIN,ARGNUM,DUPARG,ASSOC,STMTNO)
  668.         INTEGER ROUTIN,ARGNUM,DUPARG,ASSOC,STMTNO
  669.  
  670.         COMMON/PFHEAP/USHEAD,HEAP
  671.         INTEGER USHEAD,HEAP(200000)
  672.  
  673.         SAVE /PFHEAP/
  674.  
  675.         INTEGER ARG,ARG2,COUNT
  676.  
  677.         INTEGER LLFIRS,LLNEXT
  678.         EXTERNAL LLFIRS,LLNEXT
  679.  
  680.         COUNT=1
  681.         ARG=LLFIRS(HEAP,HEAP(ROUTIN+2))
  682.  100    IF (COUNT.LT.ARGNUM) THEN
  683.             COUNT=COUNT+1
  684.             ARG=LLNEXT(HEAP,ARG)
  685.             GOTO 100
  686.         END IF
  687.         COUNT=1
  688.         ARG2=LLFIRS(HEAP,HEAP(ROUTIN+2))
  689.  200    IF (COUNT.LT.DUPARG) THEN
  690.             COUNT=COUNT+1
  691.             ARG2=LLNEXT(HEAP,ARG2)
  692.             GOTO 200
  693.         END IF
  694.         IF ((HEAP(ARG+3).NE.1 .OR.
  695.      +      HEAP(ARG2+3).NE.1) .AND.
  696.      +      (HEAP(ARG+2).EQ.2 .OR.
  697.      +      HEAP(ARG2+2).EQ.2)) THEN
  698.             IF (HEAP(ARG+3).EQ.1 .OR.
  699.      +          HEAP(ARG2+3).EQ.1) THEN
  700.                 CALL PFERR(
  701.      +'U: Type 2 unsafe reference to $N from $N at statement $I',
  702.      +                 ROUTIN,ASSOC,STMTNO,0)
  703.             ELSE
  704.                 CALL PFERR(
  705.      +'E: Type 2 unsafe reference to $N from $N at statement $I',
  706.      +                 ROUTIN,ASSOC,STMTNO,0)
  707.             END IF
  708.             CALL PFERR(' Actual arguments $I a'//'nd $I are duplicated',
  709.      +                 DUPARG,ARGNUM,0,0)
  710.             CALL PFERR(' a'//'nd at least one of them is updated',0,0,0,
  711.      +                 0)
  712.         END IF
  713.  
  714.         END
  715. C ----------------------------------------------------------------------
  716. C
  717. C       P F C H U 3   -   Check a possibly unsafe reference of type 3
  718. C                         (argument from common & one is changed)
  719. C
  720.  
  721.         SUBROUTINE PFCHU3(ROUTIN,ARGNUM,CB,ASSOC,STMTNO)
  722.         INTEGER ROUTIN,ARGNUM,CB,ASSOC,STMTNO
  723.  
  724.         COMMON/PFHEAP/USHEAD,HEAP
  725.         INTEGER USHEAD,HEAP(200000)
  726.  
  727.         SAVE /PFHEAP/
  728.         COMMON/PFCB/NCB,CBDATA
  729.         INTEGER NCB,CBDATA(6,250)
  730.         SAVE /PFCB/
  731.  
  732.         INTEGER CBU,ARG,COUNT
  733.         LOGICAL UNSAFE
  734.  
  735.         INTEGER LLFIRS,LLNEXT,LLFIND
  736.         EXTERNAL LLFIRS,LLNEXT,LLFIND
  737.  
  738.         COUNT=1
  739.         ARG=LLFIRS(HEAP,HEAP(ROUTIN+2))
  740.  100    IF (COUNT.LT.ARGNUM) THEN
  741.             COUNT=COUNT+1
  742.             ARG=LLNEXT(HEAP,ARG)
  743.             GOTO 100
  744.         END IF
  745.         IF (HEAP(ARG+3).NE.1) THEN
  746.             CBU=LLFIND(HEAP,HEAP(ROUTIN+3),0,CB)
  747.             IF (CBU.NE.0) THEN
  748.                 IF (HEAP(ARG+2).EQ.2) THEN
  749.                     CALL PFERR(
  750.      +'E: Type 3 unsafe reference to $N from $N at statement $I',
  751.      +                         ROUTIN,ASSOC,STMTNO,0)
  752.                     CALL PFERR(
  753.      +' Argument $I is in common /$T/ a'//'nd is updated',
  754.      +                         ARGNUM,CBDATA(1,CB),0,0)
  755.                 ELSE IF (HEAP(CBU+1).EQ.1) THEN
  756.                         CALL PFERR(
  757.      +'U: Type 3 unsafe reference to $N from $N at statement $I',
  758.      +                             ROUTIN,ASSOC,STMTNO,0)
  759.                         CALL PFERR(
  760.      +' Argument $I is in common /$T/, which is updated',
  761.      +                             ARGNUM,CBDATA(1,CB),0,0)
  762.                 END IF
  763.             END IF
  764.         END IF
  765.  
  766.         END
  767. C ----------------------------------------------------------------------
  768. C
  769. C       P F C H U 4   -   Check a possibly unsafe reference of type 4
  770. C                         (stmt fn dummy supplied as update argument)
  771. C
  772.  
  773.         SUBROUTINE PFCHU4(ROUTIN,ARGNUM,EXTRA,ASSOC,STMTNO)
  774.         INTEGER ROUTIN,ARGNUM,EXTRA,ASSOC,STMTNO
  775.  
  776.         COMMON/PFHEAP/USHEAD,HEAP
  777.         INTEGER USHEAD,HEAP(200000)
  778.  
  779.         SAVE /PFHEAP/
  780.  
  781.         INTEGER ARG,COUNT
  782.  
  783.         INTEGER LLFIRS,LLNEXT
  784.         EXTERNAL LLFIRS,LLNEXT
  785.  
  786.         COUNT=1
  787.         ARG=LLFIRS(HEAP,HEAP(ROUTIN+2))
  788.  100    IF (COUNT.LT.ARGNUM) THEN
  789.             COUNT=COUNT+1
  790.             ARG=LLNEXT(HEAP,ARG)
  791.             GOTO 100
  792.         END IF
  793.         IF (HEAP(ARG+2).EQ.2) THEN
  794.             CALL PFERR(
  795.      +'E: Type 4 unsafe reference to $N from $N at statement $I',
  796.      +          ROUTIN,ASSOC,STMTNO,0)
  797.             CALL PFERR(
  798.      +' Statement function dummy argument passed to updated argument $I'
  799.      +                  ,ARGNUM,0,0,0)
  800.         END IF
  801.  
  802.         END
  803. C ----------------------------------------------------------------------
  804. C
  805. C       P F C H U 5   -   Check a possibly unsafe reference of type 5
  806. C                         (stmt fn dummy supplied as update argument)
  807. C
  808.  
  809.         SUBROUTINE PFCHU5(ROUTIN,ARGNUM,EXTRA,ASSOC,STMTNO)
  810.         INTEGER ROUTIN,ARGNUM,EXTRA,ASSOC,STMTNO
  811.  
  812.         COMMON/PFHEAP/USHEAD,HEAP
  813.         INTEGER USHEAD,HEAP(200000)
  814.  
  815.         SAVE /PFHEAP/
  816.  
  817.         INTEGER ARG,COUNT
  818.  
  819.         INTEGER LLFIRS,LLNEXT
  820.         EXTERNAL LLFIRS,LLNEXT
  821.  
  822.         COUNT=1
  823.         ARG=LLFIRS(HEAP,HEAP(ROUTIN+2))
  824.  100    IF (COUNT.LT.ARGNUM) THEN
  825.             COUNT=COUNT+1
  826.             ARG=LLNEXT(HEAP,ARG)
  827.             GOTO 100
  828.         END IF
  829.         IF (HEAP(ARG+2).EQ.2) THEN
  830.             CALL PFERR(
  831.      +'E: Type 5 unsafe reference to $N from $N at statement $I',
  832.      +          ROUTIN,ASSOC,STMTNO,0)
  833.             CALL PFERR(
  834.      +' Active DO-loop index passed to updated argument $I'
  835.      +                  ,ARGNUM,0,0,0)
  836.         END IF
  837.  
  838.         END
  839.